Visual Basic Controls/Visual Basic Controls.iso/vbcontrol/csfilesc/filetool.ctl

Visual Basic Form | 1998-10-01 | 13.5 KB | 380 lines

VERSION 5.00
Begin VB.UserControl FileTool
   CanGetFocus     =   0   'False
   ClientHeight    =   330
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   360
   InvisibleAtRuntime=   -1  'True
   Picture         =   "FileTool.ctx":0000
   ScaleHeight     =   330
   ScaleWidth      =   360
   ToolboxBitmap   =   "FileTool.ctx":018A
Attribute VB_Name = "FileTool"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Private Declare Function BinSearchPath Lib "kernel32" Alias "SearchPathA" (ByVal lpPath As String, ByVal lpFileName As String, ByVal lpExtension As String, ByVal nBufferLength As Long, ByVal lpBuffer As String, ByVal lpFilePart As String) As Long
Private Declare Function GetBinaryType Lib "kernel32" Alias "GetBinaryTypeA" (ByVal lpApplicationName As String, lpBinaryType As Long) As Long
Private Declare Function apiGetVersion Lib "kernel32" Alias "GetVersionExA" (ByRef lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Type SHITEMID 'mkid
    cb As Long
    abID As Byte
End Type
Private Type ITEMIDLIST 'idl
    mkid As SHITEMID
End Type
Private Type BROWSEINFO 'bi
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
    (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _
    (lpBrowseInfo As BROWSEINFO) As Long
Private Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    Flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type
Private Type OSVERSIONINFO
        dwOSVersionInfoSize As Long
        dwMajorVersion As Long
        dwMinorVersion As Long
        dwBuildNumber As Long
        dwPlatformId As Long
        szCSDVersion As String * 128
End Type
Private Const BIF_RETURNONLYFSDIRS = &H1
Private Const SCS_32BIT_BINARY = 0
Private Const SCS_DOS_BINARY = 1
Private Const SCS_WOW_BINARY = 2
Private Const SCS_PIF_BINARY = 3
Private Const SCS_POSIX_BINARY = 4
Private Const SCS_OS216_BINARY = 5
Public Enum CSBinaryTypes
    NonExecutable
    BinaryWin_32Bit
    BinaryDos
    BinaryOS2_16Bit
    BinaryPIF
    BinaryPosix
    BinaryWin_16Bit
End Enum
'Default Property Values:
Const m_def_SearchPath = ""
Const m_def_File = ""
Const m_def_FilterIndex = 1
Const m_def_Filters = "All Files (*.*)|*.*"
'Property Variables:
Dim m_SearchPath As String
Dim m_File As String
Dim m_Filters As String
Dim m_FilterIndex As Long
Public Property Get FilterIndex() As Long
Attribute FilterIndex.VB_Description = "Returns or sets a default filter for SelectFile or SelectSave dialog box."
Attribute FilterIndex.VB_HelpID = 2019
    On Error Resume Next
    FilterIndex = m_FilterIndex
End Property
Public Property Let FilterIndex(ByVal newIndex As Long)
    On Error Resume Next
    m_FilterIndex = Abs(newIndex)
    PropertyChanged "FilterIndex"
End Property
Public Property Get Filters() As String
Attribute Filters.VB_Description = "Returns or sets the filters that are displayed in the Type list box of a SelectFile or SelectSave dialog box."
Attribute Filters.VB_HelpID = 2018
    On Error Resume Next
    Filters = m_Filters
End Property
Public Property Let Filters(ByVal newFilters As String)
    On Error Resume Next
    m_Filters = newFilters
    PropertyChanged "Filters"
End Property
Private Property Get FileFilters() As String
    Dim sFilters As String
    sFilters = m_Filters & Chr$(0)
    While (InStr(1, sFilters, "|") > 0)
        Mid(sFilters, InStr(1, sFilters, "|"), 1) = Chr(0)
    Wend
    FileFilters = sFilters
End Property
Public Property Get SearchPath() As String
Attribute SearchPath.VB_Description = "Sets the path or paths to search."
Attribute SearchPath.VB_HelpID = 2011
    On Error Resume Next
    If Trim(m_SearchPath) = "" Then
        SearchPath = Environ("PATH")
    Else
        SearchPath = m_SearchPath
    End If
End Property
Public Property Let SearchPath(ByVal New_SearchPath As String)
    On Error Resume Next
    m_SearchPath = New_SearchPath
    PropertyChanged "SearchPath"
End Property
Public Property Get File() As String
Attribute File.VB_Description = "The name of the file to search for."
Attribute File.VB_HelpID = 2004
    On Error Resume Next
    File = m_File
End Property
Public Property Let File(ByVal New_File As String)
    On Error Resume Next
    m_File = New_File
    PropertyChanged "File"
End Property
Private Property Get FilePart() As String
    On Error Resume Next
    If InStr(File, ".") > 0 Then
        FilePart = Left(File, InStr(File, ".") - 1)
    End If
End Property
Private Property Get ExtPart() As String
    On Error Resume Next
    ExtPart = Right(File, Len(File) - Len(FilePart))
End Property
Public Function Search() As String
Attribute Search.VB_Description = "Used to find the location of a file specified in the File Property.  "
Attribute Search.VB_HelpID = 3002
    On Error Resume Next
    Dim tmpBuf As String, l As Long
    If Trim(File) = "" Then
        Search = ""
        Exit Function
    End If
    tmpBuf = Space(1025)
    BinSearchPath SearchPath, FilePart, ExtPart, 1024, tmpBuf, l
    tmpBuf = Left(tmpBuf, InStr(tmpBuf, vbNullChar))
    Search = tmpBuf
End Function
Public Property Get PathExists(ByVal SeachPath As String) As Boolean
Attribute PathExists.VB_Description = "Used to determine if a path exists on the users system."
Attribute PathExists.VB_HelpID = 2017
    On Error Resume Next
    Dim l As Long
    If Trim(SearchPath) = "" Then
        PathExists = False
        Exit Property
    End If
    l = GetAttr(Trim(SearchPath))
    PathExists = (l = 16 And Err = 0)
End Property
Public Property Get Exists(ByVal SearchFile As String) As Boolean
Attribute Exists.VB_Description = "A read only property to determine if a file exists on the users system."
Attribute Exists.VB_HelpID = 2002
    On Error Resume Next
    Dim l As Long
    If Trim(SearchFile) = "" Then
        Exists = False
        Exit Property
    End If
    l = GetAttr(Trim(SearchFile))
    Exists = (l <> 16 And Err = 0)
End Property
Private Property Get isNT() As Boolean
    On Error Resume Next
    Dim OSystem As OSVERSIONINFO
    OSystem.dwOSVersionInfoSize = 148
    apiGetVersion OSystem
    isNT = (OSystem.dwPlatformId = 2)
End Property
Public Property Get IsBinary(ByVal CheckFile As String) As Boolean
Attribute IsBinary.VB_Description = "A read only property to determine if a file is Binary. (NT only)"
Attribute IsBinary.VB_HelpID = 2007
    On Error Resume Next
    If Not isNT Then
        On Error GoTo 0
        Err.Raise 40004, Ambient.DisplayName, "IsBinary Property is only available under Windows NT"
        IsBinary = False
        Exit Property
    End If
    IsBinary = Not (BinaryType(CheckFile) = NonExecutable)
End Property
Public Property Get BinaryType(ByVal CheckFile As String) As CSBinaryTypes
Attribute BinaryType.VB_Description = "A read only property to determine if a file is an executable and the type of executable."
Attribute BinaryType.VB_HelpID = 2001
    On Error Resume Next
    If Not isNT Then
        On Error GoTo 0
        Err.Raise 40004, Ambient.DisplayName, "BinaryType Property is Only available under Windows NT"
        BinaryType = NonExecutable
        Exit Property
    End If
    If Not Exists(CheckFile) Then
        BinaryType = NonExecutable
        Exit Property
    End If
    Dim l As Long
    If GetBinaryType(CheckFile, l) = 0 Then
        BinaryType = NonExecutable
        Exit Property
    End If
    Select Case l
    Case SCS_32BIT_BINARY
        BinaryType = BinaryWin_32Bit
    Case SCS_DOS_BINARY
        BinaryType = BinaryDos
    Case SCS_WOW_BINARY
        BinaryType = BinaryWin_16Bit
    Case SCS_PIF_BINARY
        BinaryType = BinaryPIF
    Case SCS_POSIX_BINARY
        BinaryType = BinaryPosix
    Case SCS_OS216_BINARY
        BinaryType = BinaryOS2_16Bit
    Case Else
        BinaryType = NonExecutable
    End Select
End Property
Public Function SelectFile(Optional ByVal winTitle As String = "Select File", Optional ByVal initPath As String = "") As String
Attribute SelectFile.VB_Description = "Used to call the standard Windows ""Browse for File"" Dialog box"
Attribute SelectFile.VB_HelpID = 3006
    On Error Resume Next
    Dim OpenFile As OPENFILENAME
    Dim lReturn As Long, pos As Long
    OpenFile.lStructSize = Len(OpenFile)
    OpenFile.hwndOwner = UserControl.Parent.hwnd
    OpenFile.hInstance = App.hInstance
    OpenFile.lpstrFilter = FileFilters
    OpenFile.nFilterIndex = m_FilterIndex
    OpenFile.lpstrFile = String(257, 0)
    OpenFile.nMaxFile = 256
    OpenFile.lpstrFileTitle = OpenFile.lpstrFile
    OpenFile.nMaxFileTitle = OpenFile.nMaxFile
    OpenFile.lpstrInitialDir = IIf(initPath = "", CurDir, initPath)
    OpenFile.lpstrTitle = winTitle
    OpenFile.Flags = &H20180C
    lReturn = GetOpenFileName(OpenFile)
    If lReturn <> 0 Then
       pos = InStr(OpenFile.lpstrFile, Chr$(0))
       If pos > 0 Then _
           OpenFile.lpstrFile = Left(OpenFile.lpstrFile, pos - 1)
       SelectFile = Trim(OpenFile.lpstrFile)
    Else
       SelectFile = ""
    End If
End Function
Public Function SelectSave(Optional ByVal winTitle As String = "Save File", Optional ByVal initPath As String = "") As String
Attribute SelectSave.VB_Description = "Used to call the standard Windows Save File Dialog"
Attribute SelectSave.VB_HelpID = 3008
    On Error Resume Next
    Dim OpenFile As OPENFILENAME
    Dim lReturn As Long, pos As Long
    Dim sFilter As String
    OpenFile.lStructSize = Len(OpenFile)
    OpenFile.hwndOwner = UserControl.Parent.hwnd
    OpenFile.hInstance = App.hInstance
    OpenFile.lpstrFilter = FileFilters
    OpenFile.nFilterIndex = m_FilterIndex
    OpenFile.lpstrFile = String(257, 0)
    OpenFile.nMaxFile = 256
    OpenFile.lpstrFileTitle = OpenFile.lpstrFile
    OpenFile.nMaxFileTitle = OpenFile.nMaxFile
    OpenFile.lpstrInitialDir = IIf(initPath = "", CurDir, initPath)
    OpenFile.lpstrTitle = winTitle
    OpenFile.Flags = &H80000 + &H4 + &H200000 + &H8 + &H2 ' &H2000
    lReturn = GetOpenFileName(OpenFile)
    If lReturn <> 0 Then
       pos = InStr(OpenFile.lpstrFile, Chr$(0))
       If pos > 0 Then _
           OpenFile.lpstrFile = Left(OpenFile.lpstrFile, pos - 1)
       SelectSave = Trim(OpenFile.lpstrFile)
    Else
       SelectSave = ""
    End If
End Function
Public Function SelectPath(Optional ByVal winTitle As String = "Select Path") As String
Attribute SelectPath.VB_Description = "Used to call the ""Browse for Folder"" dialog to  allow the user to select a path."
Attribute SelectPath.VB_HelpID = 3009
    Dim bi As BROWSEINFO
    Dim IDL As ITEMIDLIST
    Dim pidl As Long
    Dim r As Long
    Dim pos As Integer
    Dim spath As String
    bi.hOwner = UserControl.hwnd
    bi.pidlRoot = 0&
    bi.lpszTitle = winTitle
    bi.ulFlags = BIF_RETURNONLYFSDIRS
    pidl = SHBrowseForFolder(bi)
    If pidl > 0 Then
        spath$ = Space$(1024)
        r = SHGetPathFromIDList(ByVal pidl&, ByVal spath$)
        If r Then
                 pos = InStr(spath$, Chr$(0))
                 SelectPath = Trim(Left(spath$, pos - 1))
        Else: SelectPath = ""
        End If
    Else: SelectPath = ""
    End If
End Function
'Initialize Properties for User Control
Private Sub UserControl_InitProperties()
    On Error Resume Next
    m_SearchPath = m_def_SearchPath
    m_File = m_def_File
    m_FilterIndex = m_def_FilterIndex
    m_Filters = m_def_Filters
End Sub
'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    On Error Resume Next
    m_SearchPath = PropBag.ReadProperty("SearchPath", m_def_SearchPath)
    m_File = PropBag.ReadProperty("File", m_def_File)
    m_FilterIndex = PropBag.ReadProperty("FilterIndex", m_def_FilterIndex)
    m_Filters = PropBag.ReadProperty("Filters", m_def_Filters)
End Sub
'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    On Error Resume Next
    Call PropBag.WriteProperty("SearchPath", m_SearchPath, m_def_SearchPath)
    Call PropBag.WriteProperty("File", m_File, m_def_File)
    Call PropBag.WriteProperty("FilterIndex", m_FilterIndex, m_def_FilterIndex)
    Call PropBag.WriteProperty("Filters", m_Filters, m_def_Filters)
End Sub
Private Sub UserControl_Resize()
    On Error Resume Next
    Static amDoing As Boolean
    If amDoing Then Exit Sub
    amDoing = True
    UserControl.Size 360, 330
    amDoing = False
End Sub
Public Sub ShowAbout()
Attribute ShowAbout.VB_UserMemId = -552
    On Error Resume Next
    dlgAbout.Show vbModal
    Unload dlgAbout
End Sub